home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / pasblk.zip / PASBLK.PAS < prev   
Pascal/Delphi Source File  |  1990-05-04  |  35KB  |  805 lines
  1. {-----------------------------------------------------------------------------}
  2. {                         Program PasBlk 1.5 900428                           }
  3. {               Show nested block structures in different colors              }
  4. {             Written By: John W. Fowler, Pres., Global Solutions             }
  5. {           Monochrome-display enhancements provided by Ron Schuster          }
  6. {-----------------------------------------------------------------------------}
  7. Uses DOS, CRT;
  8.  
  9. Type
  10.   LineRecType =     Record                      { used to store display line }
  11.                       Chars:      String[80];   { and its color attributes   }
  12.                       LineNum:    Word;                        { on the heap }
  13.                       ChangeCol:  Array[1..20] of Byte;
  14.                       Colors:     Array[0..20] of Byte;
  15.                     End;
  16.   LineRecTypePtr = ^LineRecType;
  17.  
  18. Var
  19.   PasPgm:                                                                Text;
  20.   PgmLine,FilNam,TmpLine:                                              String;
  21.   CurrntLen,I,L,C,NLines,Color0,BG0,NColors,NRecs,
  22.   State,L1End,L2Home,L1,L2,NestDepth,BlkDelimType:                    Integer;
  23.   Dummy,UserChar:                                                        Char;
  24.   LineRec:                                   Array[1..2500] of LineRecTypePtr;
  25.   TmpColors:                                             Array[0..20] of Byte;
  26.   TmpChangeCol:                                          Array[1..20] of Byte;
  27.   SeekUntil,NeedPaint:                                                Boolean;
  28.   VideoMode,ScreenWidth,DisplayPage,MaxColors:                           Byte;
  29.  
  30. Const
  31.   ColorStack: Array[1..7] of Integer = (15,10,12,9,13,11,14);
  32.   IsNotUnit: Boolean = True;
  33.   InRecord:  Boolean = False;
  34.   TruncErr:  Boolean = False;
  35.  
  36. Label SetUpLine,ShowIt,Clear,Quit;
  37.  
  38.   {---------------------------------------------------------------------------}
  39.    Procedure GetTextAttr(Var C: Char; Var Attr: Integer);
  40.   { This procedure calls Interrupt $10, Function 8: Get Character/Attribute  }
  41.    Var
  42.      Regis:     Registers;
  43.    Begin
  44.      With Regis Do Begin
  45.        AH := 8; BH := 0; {page 0}
  46.        Intr($10,Regis);
  47.        C := Chr(AL); Attr := AH;
  48.      End;
  49.    End; {GetTextAttr}
  50.  
  51.   {---------------------------------------------------------------------------}
  52.    Procedure GetVideoMode(Var VideoMode,ScreenWidth,DisplayPage: Byte);
  53.   { This procedure calls Interrupt $10, Function $0F: get video mode }
  54.    Var
  55.      Regs: Registers;
  56.    Begin
  57.      With Regs Do Begin
  58.        AH := 15;              {Get current video mode}
  59.        Intr($10,Regs);
  60.        VideoMode := AL;
  61.        ScreenWidth := AH;
  62.        DisplayPage := BH;
  63.      End; {with Regs}
  64.    End; {GetVideoMode}
  65.  
  66.   {---------------------------------------------------------------------------}
  67.    Procedure PressRETURN;
  68.    Begin
  69.      Write('Press ENTER to continue... '); ReadLn;
  70.    End; {PressRETURN}
  71.  
  72.   {---------------------------------------------------------------------------}
  73.    Procedure TooMuch;
  74.    Begin
  75.      TextColor(12);
  76.      WriteLn('Too many color changes on the same line ',
  77.              '( > 20); line no. = ',NLines);
  78.      WriteLn('Unable to process this file.'); PressRETURN;
  79.    End; {TooMuch}
  80.  
  81.   {---------------------------------------------------------------------------}
  82.    Procedure SetLabelAttrs(OnOff: Integer);
  83.    Begin
  84.      If OnOff = 1 Then Begin
  85.        TextBackground(1); TextColor(15); End
  86.      Else TextBackground(0);
  87.    End; {SetLabelAttrs}
  88.  
  89.   {---------------------------------------------------------------------------}
  90.    Procedure ExpandTabs;
  91.    Var N,L,Col: Integer;
  92.    Begin
  93.      While Pos(#9,PgmLine) > 0 Do Begin
  94.        N := Pos(#9,PgmLine);
  95.        Col := 8*Succ(N div 8);
  96.        PgmLine[N] := ' ';
  97.        For L := 1 to (Col-N) Do Insert(' ',PgmLine,N);
  98.      End; {While}
  99.    End; {ExpandTabs}
  100.  
  101.   {---------------------------------------------------------------------------}
  102.    Function NextRecOK: Boolean;
  103.    Begin
  104.      If NRecs = 2500 Then Begin
  105.       TextColor(12); WriteLn(#7); WriteLn('More than 2500 lines found;');
  106.       WriteLn('only the first 2500 can be displayed by this version.');
  107.       PressRETURN; NextRecOK := False; Exit;
  108.      End;
  109.      If MaxAvail > SizeOf(LineRecType) Then Begin
  110.        Inc(NRecs); New(LineRec[NRecs]);
  111.        NextRecOK := True; End
  112.      Else Begin
  113.       TextColor(12); WriteLn(#7,'Insufficient RAM to display entire file;');
  114.       WriteLn('only the first ',Pred(NLines),' lines can be displayed.');
  115.       PressRETURN; NextRecOK := False;
  116.      End;
  117.    End; {NextRecOK}
  118.  
  119.   {---------------------------------------------------------------------------}
  120.    Function NewColor(DC: Integer): Integer;
  121.    Begin                        { push  (DC > 0) or pop (DC < 0) color stack }
  122.      C := C + DC;
  123.      If C > MaxColors Then C := 1;
  124.      If C < 1 Then C := MaxColors;
  125.      NewColor := ColorStack[C];
  126.    End; {NewColor}
  127.  
  128.   {---------------------------------------------------------------------------}
  129.    Procedure DoScroll(N: Integer);
  130.   { This procedure uses Interupt $10, Function 6 to scroll part of the screen }
  131.    Var
  132.      Regs: Registers;
  133.    Begin
  134.      With Regs Do Begin
  135.        AH := 6; If N < 0 Then AH := 7;
  136.        AL := 0; If N <> 0 Then AL := 1;
  137.        BH := 0;
  138.        CH := 2;  CL := 0;
  139.        DH := 23; DL := 79;
  140.        Intr($10,Regs);
  141.      End; {With Regs}
  142.    End; {DoScroll}
  143.  
  144.   {---------------------------------------------------------------------------}
  145.    Procedure ShowL1L2;            { show the range of the displayed lines in }
  146.    Var LL1,LL2: Integer;              { terms of their original line numbers }
  147.    Begin
  148.      LL1 := LineRec[L1]^.LineNum;
  149.      LL2 := LineRec[L2]^.LineNum;
  150.      SetLabelAttrs(1); GotoXY(41,1);Write('        '); GotoXY(38,1);
  151.      Write(LL1,'-',LL2,' '); SetLabelAttrs(0); GotoXY(1,25);
  152.      TextColor(0); Write(' ',#8); { hide cursor }
  153.    End; {ShowL1L2}
  154.  
  155.   {---------------------------------------------------------------------------}
  156.    Procedure ShowLine(L: Integer);      { display a line with its attributes }
  157.    Var
  158.      I,N,C: Integer;
  159.    Begin
  160.      With LineRec[L]^ Do Begin
  161.        N := 1; C := Colors[0] and 15;               { get initial line color }
  162.        TextColor(C);
  163.        If Colors[0] > 15
  164.        Then Begin TextBackground(C); TextColor(0); End
  165.        Else TextBackground(0);
  166.        For I := 1 to Length(Chars) Do Begin          { run through the line, }
  167.          While I = ChangeCol[N] Do Begin         { changing attributes where }
  168.            C := Colors[N] and 15;              { the ChangeCol array says to }
  169.            TextColor(C);                     { and displaying each character }
  170.            If Colors[N] > 15
  171.            Then Begin TextBackground(C); TextColor(0); End
  172.            Else TextBackground(0);
  173.            If N < 20 Then Inc(N);
  174.          End; {I = ChangeCol[N]}
  175.          Write(Chars[I]);
  176.        End; {For I}
  177.      End; {With LineRec}
  178.    End; {ShowLine}
  179.  
  180.   {---------------------------------------------------------------------------}
  181.    Procedure ShowHome;                         { display the top of the file }
  182.    Var L: Integer;
  183.    Begin
  184.      If L1 = 1 Then Exit;                          { if already at top, exit }
  185.      DoScroll(0);                        { clear file-display part of screen }
  186.      For L := 1 to L2Home Do Begin          { loop over lines at top of file }
  187.        GotoXY(1,L+2); ShowLine(L);                        { and display them }
  188.      End; {For L}
  189.      L1 := 1; L2 := L2Home;       { record current top & bottom line numbers }
  190.    End; {ShowHome}
  191.  
  192.   {---------------------------------------------------------------------------}
  193.    Procedure ShowCurrent;                       { display a page of the file }
  194.    Var LL: Integer;
  195.    Begin
  196.      DoScroll(0);                        { clear file-display part of screen }
  197.      If KeyPressed Then Exit;                      { don't keep user waiting }
  198.      LL := 3;                                      { start display at line 3 }
  199.      NeedPaint := False;             { clear flag; screen will soon be fresh }
  200.      For L := L1 to L2 Do Begin               { loop through requested lines }
  201.        GotoXY(1,Ll); ShowLine(L); Inc(LL);                { and display them }
  202.      End; {For L}
  203.    End; {ShowCurrent}
  204.  
  205.   {---------------------------------------------------------------------------}
  206.    Function SetReverse(OnOff: Integer): Integer;        { set attributes for }
  207.    Var L: Integer;                                    { reverse video on/off }
  208.    Begin
  209.      If NColors = 20 Then Begin
  210.        TooMuch; SetReverse := -1; PressRETURN; Exit;
  211.      End;
  212.      Inc(NColors);
  213.      TmpColors[NColors] := ColorStack[C];
  214.      If OnOff < 1 Then
  215.        If VideoMode = 7 Then
  216.          TmpColors[NColors] := $1F
  217.        Else
  218.          TmpColors[NColors] := ColorStack[C] + 32;
  219.      If I + OnOff < 2 Then Begin
  220.        TmpColors[0] := TmpColors[NColors];
  221.        For L := 1 to NColors Do TmpChangeCol[L] := 0;
  222.        NColors := 0;
  223.      End {If I ...}
  224.      Else TmpChangeCol[NColors] := I + OnOff;
  225.      SetReverse := 1;
  226.    End; {SetReverse}
  227.  
  228.   {---------------------------------------------------------------------------}
  229.    Procedure ChkBeginEnd;
  230.    Var L: Integer;
  231.    Label ChkRecord;
  232.    Begin
  233.      BlkDelimType := 0;
  234.      If TmpLine[I] = 'N' Then Begin                        { check for BEGIN }
  235.        If I < 5 Then Exit;
  236.        If TmpLine[Pred(I)] <> 'I' Then Exit;
  237.        If TmpLine[I-2]     <> 'G' Then Exit;
  238.        If TmpLine[I-3]     <> 'E' Then Exit;
  239.        If TmpLine[I-4]     <> 'B' Then Exit;
  240.        If I > 5 Then Begin
  241.          L := I - 5;
  242.          If not (TmpLine[L] in [' ',';',':','}'])
  243.          Then If not ((I > 6) and (TmpLine[Pred(L)] = '*')
  244.                               and (TmpLine[L] = ')'))
  245.          Then Exit; {not BEGIN}
  246.        End; {If I > 5}
  247.        If CurrntLen > I Then Begin
  248.          L := Succ(I);
  249.          If not (TmpLine[L] in [' ','{'])
  250.          Then If not ((CurrntLen > L) and (TmpLine[L] = '(')
  251.                                       and (TmpLine[Succ(L)] = '*'))
  252.          Then Exit; {not BEGIN}
  253.        End; {If CurrntLen > I}
  254.        BlkDelimType := 1; {it is a BEGIN}
  255.      End {BEGIN}
  256.      Else Begin                                              { check for END }
  257.        If I < 3 Then Exit;
  258.        If TmpLine[Pred(I)] <> 'N' Then Goto ChkRecord;
  259.        If TmpLine[I-2]     <> 'E' Then Exit;
  260.        If I > 3 Then Begin
  261.          L := I - 3;
  262.          If not (TmpLine[L] in [' ',';',':','}'])
  263.          Then If not ((I > 4) and (TmpLine[Pred(L)] = '*')
  264.                               and (TmpLine[L] = ')'))
  265.          Then Exit; {not END}
  266.        End; {If I > 3}
  267.        If CurrntLen > I Then Begin
  268.          L := Succ(I);
  269.          If not (TmpLine[L] in [' ',';','{','.'])
  270.          Then If not ((CurrntLen > L) and (TmpLine[L] = '(')
  271.                                       and (TmpLine[Succ(L)] = '*'))
  272.          Then Exit; {not END}
  273.        End; {If CurrntLen > I}
  274.        BlkDelimType := 2; {it is an END}
  275.        InRecord := False;
  276.      End; {END}
  277.      Exit;
  278. ChkRecord:
  279.      If I < 6 Then Exit;
  280.      If TmpLine[Pred(I)] <> 'R' Then Exit;
  281.      If TmpLine[I-2]     <> 'O' Then Exit;
  282.      If TmpLine[I-3]     <> 'C' Then Exit;
  283.      If TmpLine[I-4]     <> 'E' Then Exit;
  284.      If TmpLine[I-5]     <> 'R' Then Exit;
  285.      If I > 6 Then Begin
  286.        L := I - 6;
  287.        If not (TmpLine[L] in [' ',';',':','}'])
  288.        Then If not ((I > 7) and (TmpLine[Pred(L)] = '*')
  289.                             and (TmpLine[L] = ')'))
  290.        Then Exit; {not RECORD}
  291.      End; {If I > 6}
  292.      If CurrntLen > I Then Begin
  293.        L := Succ(I);
  294.        If not (TmpLine[L] in [' ','{'])
  295.        Then If not ((CurrntLen > L) and (TmpLine[L] = '(')
  296.                                     and (TmpLine[Succ(L)] = '*'))
  297.        Then Exit; {not RECORD}
  298.      End; {If CurrntLen > I}
  299.      BlkDelimType := 3; {it is a RECORD}
  300.      InRecord := True;
  301.    End; {ChkBeginEnd}
  302.  
  303.   {---------------------------------------------------------------------------}
  304.    Procedure ChkRepUntil;
  305.    Var L: Integer;
  306. Label TryUnit,ChkObject;
  307.    Begin
  308.      BlkDelimType := 0;
  309.      If TmpLine[I] = 'T' Then Begin                       { check for REPEAT }
  310.        If I < 6 Then Goto TryUnit;
  311.        If TmpLine[Pred(I)] <> 'A' Then Goto TryUnit;
  312.        If TmpLine[I-2]     <> 'E' Then Exit;
  313.        If TmpLine[I-3]     <> 'P' Then Exit;
  314.        If TmpLine[I-4]     <> 'E' Then Exit;
  315.        If TmpLine[I-5]     <> 'R' Then Exit;
  316.        If I > 6 Then Begin
  317.          L := I - 6;
  318.          If not (TmpLine[L] in [' ',';',':','}'])
  319.          Then If not ((I > 7) and (TmpLine[Pred(L)] = '*')
  320.                               and (TmpLine[L] = ')'))
  321.          Then Exit; {Not REPEAT}
  322.        End; {If I > 6}
  323.        If CurrntLen > I Then Begin
  324.          L := Succ(I);
  325.          If not (TmpLine[L] in [' ','{'])
  326.          Then If not ((CurrntLen > L) and (TmpLine[L] = '(')
  327.                                       and (TmpLine[Succ(L)] = '*'))
  328.          Then Exit; {not REPEAT}
  329.        End; {If CurrntLen > I}
  330.        BlkDelimType := 1; {it is a REPEAT}
  331.      End {REPEAT}
  332.      Else Begin                                            { check for UNTIL }
  333.        If I < 5 Then Exit;
  334.        If TmpLine[Pred(I)] <> 'I' Then Exit;
  335.        If TmpLine[I-2]     <> 'T' Then Exit;
  336.        If TmpLine[I-3]     <> 'N' Then Exit;
  337.        If TmpLine[I-4]     <> 'U' Then Exit;
  338.        If I > 5 Then Begin
  339.          L := I - 5;
  340.          If not (TmpLine[L] in [' ',';',':','}'])
  341.          Then If not ((I > 6) and (TmpLine[Pred(L)] = '*')
  342.                               and (TmpLine[L] = ')'))
  343.          Then Exit; {not UNTIL}
  344.        End; {If I > 5}
  345.        If CurrntLen > I Then Begin
  346.          L := Succ(I);
  347.          If not (TmpLine[L] in [' ',';','{'])
  348.          Then If not ((CurrntLen > L) and (TmpLine[L] = '(')
  349.                                       and (TmpLine[Succ(L)] = '*'))
  350.          Then Exit; {not UNTIL}
  351.        End; {If CurrntLen > I}
  352.        BlkDelimType := 2; {it is an UNTIL}
  353.      End; {UNTIL}
  354.      Exit;
  355.  
  356. TryUnit:                                                    { check for UNIT }
  357.     If I < 4 Then Goto ChkObject;
  358.     If TmpLine[Pred(I)] <> 'I' Then Goto ChkObject;
  359.     If TmpLine[I-2]     <> 'N' Then Exit;
  360.     If TmpLine[I-3]     <> 'U' Then Exit;
  361.     If I > 4 Then Begin
  362.       L := I - 4;
  363.       If not (TmpLine[L] in [' ',';',':','}'])
  364.       Then If not ((I > 5) and (TmpLine[Pred(L)] = '*')
  365.                            and (TmpLine[L] = ')'))
  366.       Then Exit; {Not UNIT}
  367.     End; {If I > 4}
  368.     If CurrntLen > I Then Begin
  369.       L := Succ(I);
  370.       If not (TmpLine[L] in [' ','{'])
  371.       Then If not ((CurrntLen > L) and (TmpLine[L] = '(')
  372.                                    and (TmpLine[Succ(L)] = '*'))
  373.       Then Exit; {not UNIT}
  374.     End; {If CurrntLen > I}
  375.     BlkDelimType := 3; {it is a UNIT}
  376.     IsNotUnit := False;
  377.     Exit;
  378. ChkObject:
  379.      If I < 6 Then Exit;
  380.      If TmpLine[Pred(I)] <> 'C' Then Exit;
  381.      If TmpLine[I-2]     <> 'E' Then Exit;
  382.      If TmpLine[I-3]     <> 'J' Then Exit;
  383.      If TmpLine[I-4]     <> 'B' Then Exit;
  384.      If TmpLine[I-5]     <> 'O' Then Exit;
  385.      If I > 6 Then Begin
  386.        L := I - 6;
  387.        If not (TmpLine[L] in [' ',';',':','}'])
  388.        Then If not ((I > 7) and (TmpLine[Pred(L)] = '*')
  389.                             and (TmpLine[L] = ')'))
  390.        Then Exit; {not OBJECT}
  391.      End; {If I > 6}
  392.      If CurrntLen > I Then Begin
  393.        L := Succ(I);
  394.        If not (TmpLine[L] in [' ','(','{'])
  395.        Then Exit; {not OBJECT}
  396.      End; {If CurrntLen > I}
  397.      BlkDelimType := 4; {it is an OBJECT}
  398.    End; {ChkRepUntil}
  399.  
  400.   {---------------------------------------------------------------------------}
  401.    Function NoSplit(C: Char): Boolean;  { return True if C is a letter }
  402.    Begin
  403.      NoSplit := (C in ['A'..'Z']) or (C in ['a'..'z']);
  404.    End; {NoSplit}
  405.  
  406.   {---------------------------------------------------------------------------}
  407.    Procedure ChkCase;
  408.    Var L: Integer;
  409.    Begin
  410.      BlkDelimType := 0;                                     { check for CASE }
  411.      If InRecord Then Exit;
  412.      If I < 4 Then Exit;
  413.      If TmpLine[Pred(I)] <> 'S' Then Exit;
  414.      If TmpLine[I-2]     <> 'A' Then Exit;
  415.      If TmpLine[I-3]     <> 'C' Then Exit;
  416.      If I > 4 Then Begin
  417.        L := I - 4;
  418.        If not (TmpLine[L] in [' ',';',':','}'])
  419.        Then If not ((I > 5) and (TmpLine[Pred(L)] = '*')
  420.                             and (TmpLine[L] = ')'))
  421.        Then Exit; {not CASE}
  422.      End; {If I > 4}
  423.      If CurrntLen > I Then Begin
  424.        L := Succ(I);
  425.        If not (TmpLine[L] in [' ','{'])
  426.        Then If not ((CurrntLen > L) and (TmpLine[L] = '(')
  427.                                     and (TmpLine[Succ(L)] = '*'))
  428.        Then Exit; {not CASE}
  429.      End; {If CurrntLen > I}
  430.      BlkDelimType := 1; {it is a CASE}
  431.    End; {ChkCase}
  432.  
  433.   {---------------------------------------------------------------------------}
  434.  
  435. Begin
  436.   GetVideoMode(VideoMode,ScreenWidth,DisplayPage); { check for color display }
  437.   GetTextAttr(Dummy,Color0);
  438.   BG0 := Color0 ShR 4; Color0 := Color0 and $F;
  439.   TextBackground(0);
  440.   If VideoMode = 7 Then Begin
  441.     MaxColors := 4;
  442.     TextColor(15);
  443.   End
  444.   Else Begin
  445.     MaxColors := 7;
  446.     TextColor(9);
  447.   End;
  448.   ClrScr; WriteLn;
  449.   WriteLn('--------------------------------------------------',
  450.                    '---------------------------');
  451.   WriteLn(' PasBlk  1.5                                    Pascal ',
  452.            'Block Nesting Display');
  453.   WriteLn(' Copyright (C) 1990           Global Solutions           ',
  454.           'All Rights Reserved');
  455.   WriteLn(' This Utility May Be Distributed Free of Charge               ',
  456.           'Not to be Sold');
  457.   WriteLn('-----------------------------------------------------------',
  458.           '------------------');
  459.   WriteLn;
  460.                                    { if no command-line input, give tutorial }
  461.   If (ParamCount = 0) Then Begin
  462.     WriteLn('Usage:    PASBLK file'); WriteLn;
  463.     WriteLn('where: file = name of the Pascal program file to be displayed');
  464.     WriteLn('       (if no extension, ".PAS" will be assumed;',
  465.             ' to indicate that');
  466.     WriteLn('        there is no extension, place a period at the end)');
  467.     WriteLn;
  468.     WriteLn('    The file will be displayed with each block structure shown');
  469.     Write  ('in a different ');
  470.     If VideoMode = 7 Then
  471.       Write('attribute (the attribute')
  472.     Else
  473.       Write('color (the color');
  474.     WriteLn(' sequence wraps around if block ');
  475.     WriteLn('nesting goes deeper than ',MaxColors,
  476.             '); comments are in reverse video.');
  477.     WriteLn;
  478.     WriteLn('    The cursor control keys may be used to control scrolling');
  479.     WriteLn('while the file is being displayed on the monitor. The Esc key');
  480.     WriteLn('may be used to halt execution.');
  481.     WriteLn;
  482.     WriteLn('Limitations: 2500 displayed lines (wrapped lines count as ',
  483.             'multiple lines);');
  484.     WriteLn('             Displayed lines must fit in RAM;');
  485.     Write  ('             20 or fewer ');
  486.     If VideoMode = 7 Then
  487.       Write('attribute')
  488.     Else
  489.       Write('color');
  490.     WriteLn(' changes per displayed line.');
  491.     WriteLn; PressRETURN; Goto Quit;
  492.   End;
  493.  
  494.   If VideoMode = 7 Then Begin
  495.     ColorStack[1] := 7;
  496.     ColorStack[2] := 1;
  497.     ColorStack[3] := 15;
  498.     ColorStack[4] := 9;
  499.   End; {If VideoMode = 7}
  500.                                           { get file name for Pascal program }
  501.   FilNam := ParamStr(1);               { first parameter should be file name }
  502.   If Pos('.',FilNam) = 0 Then FilNam := FilNam + '.Pas';
  503.   Assign (PasPgm, FilNam);
  504.   {$I-} Reset(PasPgm) {$I+};
  505.                                          { if error on open, give diagnostic }
  506.   If (IOResult > 0) Then Begin
  507.     WriteLn(#7,'Unable to open file: ',FilNam); PressRETURN;
  508.     Goto Quit;
  509.   End;
  510.                                    { initialize; clip file name if necessary }
  511.   C := 1; NLines := 0; NRecs := 0;
  512.   State := 0; NestDepth := 0; SeekUntil := False;
  513.   While Pos('\',FilNam) > 0 Do Delete(FilNam,1,Pos('\',FilNam));
  514.   WriteLn('File: ',FilNam);
  515.   Write('Reading line ');
  516.                                         { read file and prepare heap records }
  517.   While Not EOF(PasPgm) Do Begin
  518.     ReadLn(PasPgm, PgmLine); Inc(NLines);
  519.     GotoXY(14,9); Write(NLines);
  520.     ExpandTabs;
  521. SetUpLine:
  522.     If Length(PgmLine) > 80
  523.     Then If (PgmLine[80] <> ' ') and (PgmLine[81] <> ' ')
  524.     Then If NoSplit(PgmLine[80])
  525.     Then Begin
  526.       I := 80;
  527.       While NoSplit(PgmLine[I]) and (I > 40) Do Dec(I);
  528.       If (I > 40) Then Begin
  529.         Inc(I);
  530.         For L := I to 80 Do Insert(' ',PgmLine,I);
  531.         If (Length(PgmLine) + 80 - I) > 255 Then TruncErr := True;
  532.       End
  533.       Else TruncErr := True;
  534.     End;
  535.     If Length(PgmLine) > 160
  536.     Then If (PgmLine[160] <> ' ') and (PgmLine[161] <> ' ')
  537.     Then If NoSplit(PgmLine[160])
  538.     Then Begin
  539.       I := 160;
  540.       While NoSplit(PgmLine[I]) and (I > 120) Do Dec(I);
  541.       If (I > 120) Then Begin
  542.         Inc(I);
  543.         For L := I to 160 Do Insert(' ',PgmLine,I);
  544.         If (Length(PgmLine) + 160 - I) > 255 Then TruncErr := True;
  545.       End
  546.       Else TruncErr := True;
  547.     End;
  548.     CurrntLen := Length(PgmLine); NColors := 0; TmpLine := PgmLine;
  549.     For I := 1 to CurrntLen Do TmpLine[I] := UpCase(TmpLine[I]);
  550.     For I := 1 to 20 Do TmpChangeCol[I] := 0;
  551.     For I := 1 to CurrntLen Do Begin
  552.       If I = 1 Then Begin
  553.         TmpColors[0] := ColorStack[C];
  554.         If State > 2 Then TmpColors[0] := ColorStack[C] + 32;
  555.       End; {If I = 1}
  556.       Case State of
  557.         0: Begin                        { not currently in quotes or comment }
  558.              Case TmpLine[I] of
  559.                'N','D': Begin
  560.                           ChkBeginEnd;                     {sets BlkDelimType}
  561.                           If BlkDelimType > 0 Then Begin
  562.                             If NColors = 20 Then Begin TooMuch; Goto Quit; End;
  563.                             Inc(NColors);
  564.                             If BlkDelimType = 1 Then Begin
  565.                               TmpColors[NColors] := NewColor(1);
  566.                               Inc(NestDepth);
  567.                               If I = 5 Then Begin
  568.                                 TmpColors[0] := TmpColors[NColors];
  569.                                 For L := 1 to NColors Do TmpChangeCol[L] := 0;
  570.                                 NColors := 0;
  571.                               End {If I = 5}
  572.                               Else TmpChangeCol[NColors] := I - 4;
  573.                             End {If BlkDelimType = 1}
  574.                             Else If BlkDelimType = 2 Then Begin
  575.                               TmpColors[NColors] := NewColor(-1);
  576.                               Dec(NestDepth);
  577.                               If CurrntLen > Succ(I)
  578.                               Then TmpChangeCol[NColors] := I + 2
  579.                               Else Begin
  580.                                 TmpChangeCol[NColors] := 0; Dec(NColors);
  581.                               End; {Else}
  582.                             End; {Else [BlkDelimType = 2]}
  583.                             If BlkDelimType = 3 Then Begin
  584.                               TmpColors[NColors] := NewColor(1);
  585.                               Inc(NestDepth);
  586.                               If I = 6 Then Begin
  587.                                 TmpColors[0] := TmpColors[NColors];
  588.                                 For L := 1 to NColors Do TmpChangeCol[L] := 0;
  589.                                 NColors := 0;
  590.                               End {If I = 6}
  591.                               Else TmpChangeCol[NColors] := I - 5;
  592.                             End {If BlkDelimType = 3}
  593.                           End; {If BlkDelimType > 0}
  594.                         End; { Begin..End block }
  595.                'T','L': Begin
  596.                           ChkRepUntil;                     {sets BlkDelimType}
  597.                           If BlkDelimType > 0 Then Begin
  598.                             If NColors = 20 Then Begin TooMuch; Goto Quit; End;
  599.                             Inc(NColors);
  600.                             If BlkDelimType = 1 Then Begin
  601.                               TmpColors[NColors] := NewColor(1);
  602.                               Inc(NestDepth);
  603.                               If I = 6 Then Begin
  604.                                 TmpColors[0] := TmpColors[NColors];
  605.                                 For L := 1 to NColors Do TmpChangeCol[L] := 0;
  606.                                 NColors := 0;
  607.                               End {If I = 6}
  608.                               Else TmpChangeCol[NColors] := I - 5;
  609.                             End {If BlkDelimType = 1}
  610.                             Else If BlkDelimType = 2 Then SeekUntil := True;
  611.                             If BlkDelimType = 3 Then Begin            { UNIT }
  612.                               TmpColors[NColors] := NewColor(1);
  613.                               Inc(NestDepth);
  614.                               If I = 4 Then Begin
  615.                                 TmpColors[0] := TmpColors[NColors];
  616.                                 For L := 1 to NColors Do TmpChangeCol[L] := 0;
  617.                                 NColors := 0;
  618.                               End {If I = 4}
  619.                               Else TmpChangeCol[NColors] := I - 3;
  620.                             End; {If BlkDelimType = 3}
  621.                             If BlkDelimType = 4 Then Begin          { OBJECT }
  622.                               TmpColors[NColors] := NewColor(1);
  623.                               Inc(NestDepth);
  624.                               If I = 6 Then Begin
  625.                                 TmpColors[0] := TmpColors[NColors];
  626.                                 For L := 1 to NColors Do TmpChangeCol[L] := 0;
  627.                                 NColors := 0;
  628.                               End {If I = 6}
  629.                               Else TmpChangeCol[NColors] := I - 5;
  630.                             End {If BlkDelimType = 4}
  631.                           End; {If BlkDelimType > 0}
  632.                         End; { Repeat..Until block }
  633.                    'E': Begin
  634.                           ChkCase;                         {sets BlkDelimType}
  635.                           If BlkDelimType > 0 Then Begin
  636.                             If NColors = 20 Then Begin TooMuch; Goto Quit; End;
  637.                             Inc(NColors);
  638.                             If BlkDelimType = 1 Then Begin
  639.                               TmpColors[NColors] := NewColor(1);
  640.                               Inc(NestDepth);
  641.                               If I = 4 Then Begin
  642.                                 TmpColors[0] := TmpColors[NColors];
  643.                                 For L := 1 to NColors Do TmpChangeCol[L] := 0;
  644.                                 NColors := 0;
  645.                               End {If I = 6}
  646.                               Else TmpChangeCol[NColors] := I - 3;
  647.                             End {If BlkDelimType = 1}
  648.                           End; {If BlkDelimType > 0}
  649.                         End; { Case.. block beginning }
  650.                ';': If SeekUntil Then Begin
  651.                       SeekUntil := False;
  652.                       TmpColors[NColors] := NewColor(-1);
  653.                       Dec(NestDepth);
  654.                       If CurrntLen > I Then TmpChangeCol[NColors] := Succ(I);
  655.                     End;
  656.                #39: State := 1;                     { state 1 is in  '....'  }
  657. (*             '"': State := 2;   *)                { state 2 is in  "...."  }
  658.                '*': If I > 1                        { state 3 is in (*....*) }
  659.                     Then If PgmLine[Pred(I)] = '('
  660.                     Then Begin
  661.                       State := 3; If SetReverse(-1) < 0 Then Goto Quit;
  662.                     End; {entered state 3}
  663.                '{': Begin                          (* state 4 is in  {....} *)
  664.                       State := 4; If SetReverse(0) < 0 Then Goto Quit;
  665.                     End; {entered state 4}
  666.              End; {Case PgmLine[I]}
  667.            End; {0}
  668.         1: If PgmLine[I] = #39 Then State := 0;      {  currently in '....'  }
  669. (*      2: If PgmLine[I] = '"' Then State := 0; *)   {  currently in "...."  }
  670.         3: If PgmLine[I] = ')'                       { currently in (*....*) }
  671.            Then If I > 1
  672.            Then If PgmLine[Pred(I)] = '*'
  673.            Then Begin
  674.              State := 0; If SetReverse(1) < 0 Then Goto Quit;
  675.            End; {3}
  676.         4: If PgmLine[I] = '}' Then Begin           (* currently in  {....} *)
  677.              State := 0; If SetReverse(1) < 0 Then Goto Quit;
  678.            End; {4}
  679.       End; {Case State}
  680.                                                         { process wraparound }
  681.       If I = 80 Then Begin
  682.         If not NextRecOK Then Goto ShowIt;    { increments NRecs & allocates }
  683.         With LineRec[NRecs]^ Do Begin                     { next heap record }
  684.           For L := 0 to NColors Do Colors[L] := TmpColors[L];
  685.           For L := 1 to 20 Do ChangeCol[L] := TmpChangeCol[L];
  686.           LineNum := NLines;
  687.           Chars := Copy(PgmLine,1,80); Delete(PgmLine,1,80);
  688.         End; {With LineRec}
  689.         If Length(PgmLine) > 0 Then Goto SetUpLine;
  690.       End; {If I = 80}
  691.     End; {For I}
  692.                    { put line on heap if not just done as part of wraparound }
  693.     If CurrntLen <> 80 Then Begin
  694.       If not NextRecOK Then Goto ShowIt;      { increments NRecs & allocates }
  695.       With LineRec[NRecs]^ Do Begin                       { next heap record }
  696.         For L := 0 to NColors Do Colors[L] := TmpColors[L];
  697.         For L := 1 to 20 Do ChangeCol[L] := TmpChangeCol[L];
  698.         LineNum := NLines;
  699.         Chars := Copy(PgmLine,1,80); Delete(PgmLine,1,80);
  700.       End; {With LineRec}
  701.     End; {If CurrntLen}
  702.     If KeyPressed Then Begin
  703.       While KeyPressed Do Dummy := ReadKey;
  704.       GotoXY(1,10); Write('Abort (y/n) ? ');
  705.       Repeat Dummy := UpCase(ReadKey) Until Dummy in ['N','Y'];
  706.       If Dummy = 'Y' Then Goto Quit;
  707.       GotoXY(1,10); ClrEoL;
  708.     End; {If KeyPressed}
  709.   End;  {While Not EOF(PasPgm)}
  710.   Close(PasPgm); If SeekUntil Then If NestDepth >= 0 Then Inc(NestDepth)
  711.                                                      Else Dec(NestDepth);
  712.   If NestDepth <> 0 Then If (IsNotUnit or (NestDepth <> 1)) Then Begin
  713.     WriteLn; I := NestDepth;
  714.     If not IsNotUnit Then Dec(I);
  715.     If Abs(I) = 1 Then Write('A') Else Write(Abs(I));
  716.     Write(' block nesting error');
  717.     If Abs(I) = 1 Then Write(' was') Else Write('s were');
  718.     WriteLn(' found.',#7); PressRETURN;
  719.   End; {If NestDepth}
  720.  
  721.   If TruncErr Then Begin
  722.     WriteLn(#7);
  723.     WriteLn('Line truncation occurred; block nesting errors may result.');
  724.     If (not IsNotUnit and (NestDepth = 1)) or (IsNotUnit and (NestDepth = 0))
  725.     Then WriteLn('Nesting levels completed normally, however.');
  726.     WriteLn(
  727.    'Check lines that were broken in the middle of a word for display wraparound');
  728.     WriteLn(
  729.    'and lines that may have been extended beyond 255 columns in order to insert');
  730.     WriteLn(
  731.    'blanks (to avoid wrapping in the middle of a word); block-delimiting keywords');
  732.     WriteLn(
  733.    'can be missed by the program in such cases.');
  734.     PressRETURN;
  735.   End; {If TruncErr}
  736.  
  737. ShowIt:
  738.   GotoXY(1,1); ClrScr; SetLabelAttrs(1);
  739.   Write(' File:                         Lines ',
  740.         '                       Total Lines:        ');
  741.   GotoXY(8,1); Write(FilNam); GotoXY(74,1); Write(NLines);
  742.   GotoXY(1,2); Write(' Active Keys:             '#24,' ',#25,
  743.                      ' PgUp PgDn Home End            Esc to Exit         ');
  744.   SetLabelAttrs(0);
  745.   L1End := NRecs - 21; If L1End < 1 Then L1End := 1;
  746.   L2Home := 22; If NRecs < 22 Then L2Home := NRecs;
  747.   L1 := -9; ShowHome; NeedPaint := False;
  748.  
  749.   Repeat
  750.     If NeedPaint Then ShowCurrent;
  751.     ShowL1L2;
  752.     UserChar := ReadKey; If UserChar = #27 Then Goto Clear;
  753.     If (UserChar = #0) and KeyPressed Then Begin
  754.       UserChar := ReadKey;
  755.       Case UserChar of
  756.         #71: ShowHome;                                                { Home }
  757.         #72: If L1 > 1 Then Begin                                       { Up }
  758.                DoScroll(-1); Dec(L1); Dec(L2);
  759.                GotoXY(1,3); ShowLine(L1);
  760.              End; {72}
  761.         #73: If L1 > 1 Then Begin                                     { PgUp }
  762.                I := L1 - 18; If I < 1 Then I := 1;
  763.                For L := 1 to L1-I Do Begin
  764.                  Dec(L1);
  765.                  If not KeyPressed Then Begin
  766.                    DoScroll(-1); GotoXY(1,3); ShowLine(L1);
  767.                  End
  768.                  Else NeedPaint := True;  
  769.              End; {For L}
  770.                L2 := L1 + 21;
  771.                If L2 > NRecs Then L2 := NRecs;
  772.              End; {73}
  773.         #79: If L1 < L1End Then Begin                                  { End }
  774.                DoScroll(0); I := 2;
  775.                For L := L1End to NRecs Do Begin
  776.                  Inc(I); GotoXY(1,I); ShowLine(L);
  777.                End; {For L}
  778.                L1 := L1End; L2 := NRecs;
  779.              End; {79}
  780.         #80: If L1 < L1End Then Begin                                 { Down }
  781.                DoScroll(1); Inc(L1); Inc(L2);
  782.                GotoXY(1,24); ShowLine(L2);
  783.              End; {80}
  784.         #81: If L1 < L1End Then Begin                                 { PgDn }
  785.                I := L1 + 18; If I > L1End Then I := L1End;
  786.                For L := 1 to I-L1 Do Begin
  787.                  Inc(L2);
  788.                  If not KeyPressed Then Begin
  789.                    DoScroll(1); GotoXY(1,24); ShowLine(L2);
  790.                  End
  791.                  Else NeedPaint := True;
  792.                End; {For L}
  793.                L1 := I;
  794.              End; {81}
  795.       End; {Case UserChar}
  796.     End; {If UserChar = 0...}
  797.   Until UserChar = #27;
  798.  
  799. Clear:
  800.   ClrScr; For I := 1 to 25 Do WriteLn;
  801.  
  802. Quit:
  803.   TextColor(Color0); TextBackground(BG0); ClrScr;
  804. End.
  805.